home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual BASIC 5.0 (Ent. Edition) / Vb5ent Extractor.EXE / VB / SAMPLES / COMPTOOL / ACTVCOMP / COFFEE / XTIMERS.BAS < prev    next >
Encoding:
BASIC Source File  |  1996-12-03  |  8.0 KB  |  216 lines
  1. Attribute VB_Name = "XTimerSupport"
  2. Option Explicit
  3. '================================================
  4. ' WARNING!  DO NOT press the End button while
  5. '   debugging this project!  While in Break
  6. '   mode, do NOT make edits that reset the
  7. '   project!
  8. '
  9. ' This module is dangerous because it uses the
  10. '   SetTimer API and the AddressOf operator to
  11. '   set up a code-only timer.  Once such a
  12. '   timer is set up, the system will continue
  13. '   to call the TimerProc function EVEN AFTER
  14. '   YOU RETURN TO DESIGN TIME.
  15. '
  16. ' Since TimerProc isn't available at design
  17. '   time, the system will cause a PROGRAM
  18. '   FAULT in Visual Basic.
  19. '
  20. ' When debugging this module, you need to make
  21. '   sure that all system timers have been
  22. '   stopped (using KillTimer) before returning
  23. '   to design time.  You can do this by calling
  24. '   SCRUB from the Immediate window.
  25. '
  26. ' Call-back timers are inherently dangerous.
  27. '   It's much safer to use Timer controls for
  28. '   most of your development process, and only
  29. '   switch to call-back timers at the very
  30. '   end.
  31. '==================================================
  32.  
  33. ' Amount to increase size of the array maxti when more
  34. '   active timers are needed.  (See 'MoreRoom:' below.)
  35. Const MAXTIMERINCREMEMT = 5
  36.  
  37. Private Type XTIMERINFO   ' Hungarian xti
  38.     xt As XTimer
  39.     id As Long
  40.     blnReentered As Boolean
  41. End Type
  42.  
  43. Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerProc As Long) As Long
  44. Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
  45.  
  46. ' maxti is an array of active XTimer objects.  The reason
  47. ' -----   for using an array of user-defined types
  48. '   instead of a Collection object is to get early
  49. '   binding when we raise the XTimer object's Tick event.
  50. Private maxti() As XTIMERINFO
  51. '
  52. ' mintMaxTimers tells us how large the array maxti is at
  53. ' -------------   any given time.
  54. Private mintMaxTimers As Integer
  55.  
  56. ' BeginTimer function is called by an XTimer object when
  57. ' -------------------   the XTimer's Interval property is
  58. '   set to a new non-zero value.
  59. '
  60. ' The function makes the API calls required to set up a
  61. '   timer.  If a timer is successfully created, the
  62. '   function puts a reference to the XTimer object into
  63. '   the array maxti.  This reference will be used to call
  64. '   the method that raises the XTimer's Tick event.
  65. '
  66. Public Function BeginTimer(ByVal xt As XTimer, ByVal Interval As Long)
  67.     Dim lngTimerID As Long
  68.     Dim intTimerNumber As Integer
  69.     
  70.     lngTimerID = SetTimer(0, 0, Interval, AddressOf TimerProc)
  71.     ' Success is a non-zero return from SetTimer.  If we can't
  72.     '   get a timer, raise an error.
  73.     If lngTimerID = 0 Then Err.Raise vbObjectError + 31013, , "No timers available"
  74.     
  75.     ' The following loop locates the first available slot
  76.     '   in the array maxti.  If the upper bound is exceeded,
  77.     '   an error occurs and the array is made larger.  (If
  78.     '   you compile this DLL to Native Code, DO NOT turn off
  79.     '   Bounds Checking!)
  80.     For intTimerNumber = 1 To mintMaxTimers
  81.         If maxti(intTimerNumber).id = 0 Then Exit For
  82.     Next
  83.     '
  84.     ' If no empty space was found, increase the
  85.     '   size of the array.
  86.     If intTimerNumber > mintMaxTimers Then
  87.         mintMaxTimers = mintMaxTimers + MAXTIMERINCREMEMT
  88.         ReDim Preserve maxti(1 To mintMaxTimers)
  89.     End If
  90.     '
  91.     ' Save a reference to use when raising the
  92.     '   XTimer object's Tick event.
  93.     Set maxti(intTimerNumber).xt = xt
  94.     '
  95.     ' Save the timer id returned by the SetTimer API, and
  96.     '   return the value to the XTimer object.
  97.     maxti(intTimerNumber).id = lngTimerID
  98.     maxti(intTimerNumber).blnReentered = False
  99.     BeginTimer = lngTimerID
  100. End Function
  101.  
  102. ' TimerProc is the timer procedure which the system will
  103. ' ---------   call whenever one of your timers goes off.
  104. '
  105. ' IMPORTANT -- Because this procedure must be in a
  106. '   standard module, all of your timer objects must share
  107. '   it.  This means the procedure must identify which timer
  108. '   has gone off.  This is done by searching the array
  109. '   maxti for the ID of the timer (idEvent).
  110. '
  111. ' If this Sub declaration is wrong, PROGRAM FAULTS will
  112. '   occur!  This is one of the dangers of using APIs
  113. '   that require call-back functions.
  114. '
  115. Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal lngSysTime As Long)
  116.     Dim intCt As Integer
  117.  
  118.     For intCt = 1 To mintMaxTimers
  119.         If maxti(intCt).id = idEvent Then
  120.             ' Don't raise the event if an earlier
  121.             '   instance of this event is still
  122.             '   being processed.
  123.             If maxti(intCt).blnReentered Then Exit Sub
  124.             ' The blnReentered flag blocks further
  125.             '   instances of this event until the
  126.             '   current instance finishes.
  127.             maxti(intCt).blnReentered = True
  128.             On Error Resume Next
  129.             ' Raise the Tick event for the appropriate
  130.             '   XTimer object.
  131.             maxti(intCt).xt.RaiseTick
  132.             If Err.Number <> 0 Then
  133.                 ' If an error occurs, the XTimer has
  134.                 '   somehow managed to terminate without
  135.                 '   first letting go of its timer.  Clean
  136.                 '   up the orphaned timer, to prevent GP
  137.                 '   faults later.
  138.                 KillTimer 0, idEvent
  139.                 maxti(intCt).id = 0
  140.                 '
  141.                 ' Release the reference to the
  142.                 '   XTimer object.
  143.                 Set maxti(intCt).xt = Nothing
  144.             End If
  145.             '
  146.             ' Allow this event to enter TimerProc
  147.             '   again.
  148.             maxti(intCt).blnReentered = False
  149.             Exit Sub
  150.         End If
  151.     Next
  152.     ' The following line is a fail-safe, in case an
  153.     '   XTimer somehow got freed without the Windows
  154.     '   system timer getting killed.
  155.     '
  156.     ' Execution can also reach this point because of
  157.     '   a known bug with NT 3.51, whereby you may
  158.     '   receive one extra timer event AFTER you have
  159.     '   executed the KillTimer API.
  160.     KillTimer 0, idEvent
  161. End Sub
  162.  
  163. ' EndTimer procedure is called by the XTimer whenever
  164. ' ------------------   the Enabled property is set to
  165. '   False, and whenever a new timer interval is required.
  166. '   There is no way to reset a system timer, so the only
  167. '   way to change the interval is to kill the existing
  168. '   timer and then call BeginTimer to start a new one.
  169. '
  170. Public Sub EndTimer(ByVal xt As XTimer)
  171.     Dim lngTimerID As Long
  172.     Dim intCt As Integer
  173.     
  174.     ' Ask the XTimer for its TimerID, so we can search the
  175.     '   array for the correct XTIMERINFO.  (You could
  176.     '   search for the XTimer reference itself, using the
  177.     '   Is operator to compare xt with maxti(intCt).xt, but
  178.     '   that wouldn't be as fast.)
  179.     lngTimerID = xt.TimerID
  180.     '
  181.     ' If the timer ID is zero, EndTimer has been
  182.     '   called in error.
  183.     If lngTimerID = 0 Then Exit Sub
  184.     '
  185.     For intCt = 1 To mintMaxTimers
  186.         If maxti(intCt).id = lngTimerID Then
  187.             ' Kill the system timer.
  188.             KillTimer 0, lngTimerID
  189.             '
  190.             ' Release the reference to the XTimer
  191.             '   object.
  192.             Set maxti(intCt).xt = Nothing
  193.             '
  194.             ' Clean up the ID, to free the slot for
  195.             '   a new active timer.
  196.             maxti(intCt).id = 0
  197.             Exit Sub
  198.         End If
  199.     Next
  200. End Sub
  201.  
  202. ' Scrub procedure is a safety valve for debugging purposes
  203. ' ---------------   only:  If you have to End this project
  204. '   while there are XTimer objects active, call Scrub from
  205. '   the Immediate pane.  This will call KillTimer for all
  206. '   of the system timers, so that the development
  207. '   environment can safely return to design mode.
  208. '
  209. Public Sub Scrub()
  210.     Dim intCt As Integer
  211.     ' Kill remaining active timers.
  212.     For intCt = 1 To mintMaxTimers
  213.         If maxti(intCt).id <> 0 Then KillTimer 0, maxti(intCt).id
  214.     Next
  215. End Sub
  216.